home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / gnu / tforth21.lha / tile-forth-2.1 / lib / stacks.f83 < prev    next >
Text File  |  1991-09-14  |  3KB  |  109 lines
  1. \
  2. \  VECTOR REPRESENTED STACKS
  3. \
  4. \  Copyright (C) 1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 1 April 1990
  15. \
  16. \  Last updated on: 23 July 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth, structures, blocks
  20. \
  21. \  Description:
  22. \       Management of vector represented stacks with cell stack width.
  23. \
  24. \  Copying:
  25. \       This program is free software; you can redistribute it and\or modify
  26. \       it under the terms of the GNU General Public License as published by
  27. \       the Free Software Foundation; either version 1, or (at your option)
  28. \       any later version.
  29. \
  30. \       This program is distributed in the hope that it will be useful,
  31. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  32. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  33. \       GNU General Public License for more details.
  34. \
  35. \       You should have received a copy of the GNU General Public License
  36. \       along with this program; see the file COPYING.  If not, write to
  37. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  38.  
  39. .( Loading Stacks definitions...) cr
  40.   
  41. #include structures.f83
  42. #include blocks.f83
  43.  
  44. vocabulary stacks ( -- )
  45.  
  46. structures blocks stacks definitions
  47.  
  48. struct.type STACK ( size -- )
  49.   ptr  +top ( stack -- addr) private
  50.   long +bytes ( stack -- addr) private
  51.   ptr  +bottom ( stack --- addr) private
  52. struct.init ( size stack -- )
  53.   >r cells dup allot r@ +bytes !
  54.   here r@ +bottom !
  55.   here r> +top !
  56. struct.end
  57.  
  58. : empty-stack ( stack -- )  
  59.   dup +bottom @ swap +top !
  60. ;
  61.  
  62. : size-stack ( stack -- num)
  63.   +bytes @ cell /
  64. ;
  65.  
  66. : depth-stack ( stack -- num)  
  67.   dup +bottom @ swap +top @ - cell /
  68. ;
  69.  
  70. : ?empty-stack ( stack -- bool)  
  71.   dup +bottom @ swap +top @ =
  72. ;
  73.  
  74. : ?full-stack ( stack -- bool)  
  75.   dup >r +bottom @ r@ +top @ - r> +bytes @ =
  76. ;
  77.  
  78. : push ( element stack -- )  
  79.   +top dup cell negate swap +! @ !
  80. ;
  81.  
  82. : pop ( stack -- element) 
  83.   +top dup @ @ cell rot +!
  84. ;
  85.  
  86. : map-stack ( stack block[element -- ] -- )
  87.   swap dup +bottom @ swap +top @ ?do
  88.     i @ swap dup >r call r>
  89.   cell +loop
  90.   drop
  91. ; 
  92.  
  93. : ?map-stack ( stack block[element -- bool] -- )
  94.   swap dup +bottom @ swap +top @ ?do
  95.     i @ swap dup >r call r> swap
  96.     if leave then
  97.   cell +loop
  98.   drop
  99. ;
  100.  
  101. : .stack ( stack -- )
  102.   ." stack#" dup . ." [" dup depth-stack 0 .r ." ] "
  103.   block[ ( element -- )
  104.     ." /" 0 .r
  105.   ]; map-stack 
  106. ;
  107.  
  108. forth only
  109.